home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / TRACE.LSP < prev    next >
Lisp/Scheme  |  1994-02-05  |  14KB  |  313 lines
  1. ;; Tracer
  2. ;; Bruno Haible 13.2.1990, 15.3.1991, 4.4.1991
  3.  
  4. ; (TRACE) liefert Liste der getraceten Funktionen
  5. ; (TRACE fun ...) tracet die Funktionen fun, ... zusätzlich.
  6. ; Format für fun:
  7. ;   Entweder ein Symbol
  8. ;        symbol
  9. ;   oder eine Liste aus einem Symbol und einigen Keyword-Argumenten (paarig!)
  10. ;        (symbol
  11. ;          [:suppress-if form]   ; kein Trace-Output, solange form erfüllt ist
  12. ;          [:step-if form]       ; Trace geht in den Stepper, falls form erfüllt
  13. ;          [:pre form]           ; führt vor Funktionsaufruf form aus
  14. ;          [:post form]          ; führt nach Funktionsaufruf form aus
  15. ;          [:pre-break-if form]  ; Trace geht vor Funktionsaufruf in die Break-Loop,
  16. ;                                ; falls form erfüllt
  17. ;          [:post-break-if form] ; Trace geht nach Funktionsaufruf in die Break-Loop,
  18. ;                                ; falls form erfüllt
  19. ;          [:pre-print form]     ; gibt die Werte von form vor Funktionsaufruf aus
  20. ;          [:post-print form]    ; gibt die Werte von form nach Funktionsaufruf aus
  21. ;          [:print form]         ; gibt die Werte von form vor und nach Funktionsaufruf aus
  22. ;        )
  23. ;   In all diesen Formen kann auf *TRACE-FUNCTION* (die Funktion selbst)
  24. ;   und *TRACE-ARGS* (die Argumente an die Funktion)
  25. ;   und *TRACE-FORM* (der Funktions-/Macro-Aufruf als Form)
  26. ;   und nach Funktionsaufruf auch auf *TRACE-VALUES* (die Liste der Werte
  27. ;   des Funktionsaufrufs) zugegriffen werden,
  28. ;   und mit RETURN kann der Aufruf mit gegebenen Werten verlassen werden.
  29. ; (UNTRACE) liefert Liste der getraceten Funktionen, streicht sie alle.
  30. ; (UNTRACE symbol ...) streicht symbol, ... aus der Liste der getraceten
  31. ;   Funktionen.
  32. ; TRACE und UNTRACE sind auch auf Funktionen (SETF symbol) und auf Macros anwendbar,
  33. ;   nicht jedoch auf lokal definierte Funktionen und Macros.
  34.  
  35. (in-package "LISP")
  36. (export '(trace untrace
  37.           *trace-function* *trace-args* *trace-form* *trace-values*
  38. )        )
  39. (in-package "SYSTEM")
  40.  
  41. (proclaim '(special *trace-function* *trace-args* *trace-form* *trace-values*))
  42. (defvar *traced-functions* nil) ; Liste der momentan getraceden Funktionsnamen
  43.   ; Solange ein Funktionsname funname [bzw. genauer: das Symbol
  44.   ; symbol = (get-funname-symbol funname)] getraced ist, enthält
  45.   ; die Property sys::traced-definition den alten Inhalt der Funktionszelle,
  46.   ; die Property sys::tracing-definition den neuen Inhalt der Funktionszelle,
  47.   ; und ist der Funktionsname Element der Liste *traced-functions*.
  48.   ; Währenddessen kann sich der Inhalt der Funktionszelle jedoch ändern!
  49.   ; Jedenfalls gilt stets:
  50.   ;        (and (fboundp symbol)
  51.   ;             (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  52.   ;        )
  53.   ; ===>   (member funname *traced-functions* :test #'equal)
  54.   ; <==>   (get symbol 'sys::traced-definition)
  55. (defvar *trace-level* 0) ; Verschachtelungstiefe bei der Trace-Ausgabe
  56.  
  57. ; Funktionen, die der Tracer zur Laufzeit aufruft und die der Benutzer
  58. ; tracen könnte, müssen in ihrer ungetraceden Form aufgerufen werden.
  59. ; Statt (fun arg ...) verwende daher (SYS::%FUNCALL '#,#'fun arg ...)
  60. ; oder (SYS::%FUNCALL (LOAD-TIME-VALUE #'fun) arg ...).
  61. ; Dies gilt für alle hier verwendeten Funktionen von #<PACKAGE LISP> außer
  62. ; CAR, CDR, CONS, APPLY, VALUES-LIST (die alle inline compiliert werden).
  63.  
  64. (defmacro trace (&rest funs)
  65.   (if (null funs)
  66.     '*traced-functions*
  67.     (cons 'append
  68.       (mapcar #'(lambda (fun)
  69.                   (if (or (atom fun) (function-name-p fun))
  70.                     (trace1 fun)
  71.                     (apply #'trace1 fun)
  72.                 ) )
  73.               funs
  74.     ) )
  75. ) )
  76.  
  77. (defun trace1 (funname &key (suppress-if nil) (step-if nil)
  78.                             (pre nil) (post nil)
  79.                             (pre-break-if nil) (post-break-if nil)
  80.                             (pre-print nil) (post-print nil) (print nil)
  81.                        &aux (old-function (gensym)) (macro-flag (gensym))
  82.               )
  83.   (unless (function-name-p funname)
  84.     (error #+DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  85.            #+ENGLISH "~S: function name should be a symbol, not ~S"
  86.            #+FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S"
  87.            'trace funname
  88.   ) )
  89.   (let ((symbolform
  90.           (if (atom funname)
  91.             `',funname
  92.             `(load-time-value (get-setf-symbol ',(second funname)))
  93.        )) )
  94.     `(block nil
  95.        (unless (fboundp ,symbolform) ; Funktion überhaupt definiert?
  96.          (warn #+DEUTSCH "~S: Funktion ~S ist nicht definiert."
  97.                #+ENGLISH "~S: undefined function ~S"
  98.                #+FRANCAIS "~S : La fonction ~S n'est pas définie."
  99.                'trace ',funname
  100.          )
  101.          (return nil)
  102.        )
  103.        (when (special-form-p ,symbolform) ; Special-Form: nicht tracebar
  104.          (warn #+DEUTSCH "~S: Special-Form ~S kann nicht getraced werden."
  105.                #+ENGLISH "~S: cannot trace special form ~S"
  106.                #+FRANCAIS "~S : La forme spéciale ~S ne peut pas être tracée."
  107.                'trace ',funname
  108.          )
  109.          (return nil)
  110.        )
  111.        (let* ((,old-function (symbol-function ,symbolform))
  112.               (,macro-flag (consp ,old-function)))
  113.          (unless (eq ,old-function (get ,symbolform 'sys::tracing-definition)) ; schon getraced?
  114.            (setf (get ,symbolform 'sys::traced-definition) ,old-function)
  115.            (pushnew ',funname *traced-functions* :test #'equal)
  116.          )
  117.          (format t #+DEUTSCH "~&;; ~:[Funktion~;Macro~] ~S wird getraced."
  118.                    #+ENGLISH "~&;; Tracing ~:[function~;macro~] ~S."
  119.                    #+FRANCAIS "~&;; Traçage ~:[de la fonction~;du macro~] ~S."
  120.                    ,macro-flag ',funname
  121.          )
  122.          (replace-in-fenv (get ,symbolform 'sys::traced-definition) ',funname
  123.            ,old-function
  124.            (setf (get ,symbolform 'sys::tracing-definition)
  125.              (setf (symbol-function ,symbolform)
  126.                ; neue Funktion, die die ursprüngliche ersetzt:
  127.                ,(let ((newname (concat-pnames "TRACED-" (get-funname-symbol funname)))
  128.                       (body
  129.                         `((declare (compile) (inline car cdr cons apply values-list))
  130.                           (let ((*trace-level* (trace-level-inc)))
  131.                             (block nil
  132.                               (unless ,suppress-if
  133.                                 (trace-pre-output)
  134.                               )
  135.                               ,@(when pre-print
  136.                                   `((trace-print (multiple-value-list ,pre-print)))
  137.                                 )
  138.                               ,@(when print
  139.                                   `((trace-print (multiple-value-list ,print)))
  140.                                 )
  141.                               ,pre
  142.                               ,@(when pre-break-if
  143.                                   `((when ,pre-break-if (sys::break-loop t)))
  144.                                 )
  145.                               (let ((*trace-values*
  146.                                       (multiple-value-list
  147.                                         (if ,step-if
  148.                                           (trace-step-apply)
  149.                                           (apply *trace-function* *trace-args*)
  150.                                    )) ) )
  151.                                 ,@(when post-break-if
  152.                                     `((when ,post-break-if (sys::break-loop t)))
  153.                                   )
  154.                                 ,post
  155.                                 ,@(when print
  156.                                     `((trace-print (multiple-value-list ,print)))
  157.                                   )
  158.                                 ,@(when post-print
  159.                                     `((trace-print (multiple-value-list ,post-print)))
  160.                                   )
  161.                                 (unless ,suppress-if
  162.                                   (trace-post-output)
  163.                                 )
  164.                                 (values-list *trace-values*)
  165.                          )) ) )
  166.                      ))
  167.                   `(if (not ,macro-flag)
  168.                      (function ,newname
  169.                        (lambda (&rest *trace-args*
  170.                                 &aux (*trace-form* (make-apply-form ',funname *trace-args*))
  171.                                      (*trace-function* (get-traced-definition ,symbolform))
  172.                                )
  173.                          ,@body
  174.                      ) )
  175.                      (cons 'sys::macro
  176.                        (function ,newname
  177.                          (lambda (&rest *trace-args*
  178.                                   &aux (*trace-form* (car *trace-args*))
  179.                                        (*trace-function* (cdr (get-traced-definition ,symbolform)))
  180.                                  )
  181.                            ,@body
  182.                      ) ) )
  183.                    )
  184.                 )
  185.        ) ) ) )
  186.        '(,funname)
  187.      )
  188. ) )
  189.  
  190. ;; Hilfsfunktionen:
  191. ; Funktionsreferenzen, die vom LABELS bei DEFUN kommen, ersetzen:
  192. (defun replace-in-fenv (fun funname old new)
  193.   (when (and (sys::closurep fun) (not (compiled-function-p fun)))
  194.     ; interpretierte Closure
  195.     (let ((fenv (sys::%record-ref fun 5))) ; Funktions-Environment
  196.       (when fenv ; falls nichtleer, durchlaufen:
  197.         (do ((l (length fenv)) ; l = 2 * Anzahl der Bindungen + 1
  198.              (i 1 (+ i 2)))
  199.             ((eql i l))
  200.           (when (and (equal (svref fenv (- i 1)) funname) (eq (svref fenv i) old))
  201.             (setf (svref fenv i) new)
  202.         ) )
  203. ) ) ) )
  204. ; Nächsthöheres Trace-Level liefern:
  205. (defun trace-level-inc ()
  206.   (%funcall '#,#'1+ *trace-level*)
  207. )
  208. ; Ursprüngliche Funktionsdefinition holen:
  209. (defun get-traced-definition (symbol)
  210.   (%funcall '#,#'get symbol 'sys::traced-definition)
  211. )
  212. ; Anwenden, aber durchsteppen:
  213. (defun trace-step-apply ()
  214.   ;(eval `(step (apply ',*trace-function* ',*trace-args*)))
  215.   (%funcall '#,#'eval
  216.     (cons 'step
  217.      (cons
  218.        (cons 'apply
  219.         (cons (cons 'quote (cons *trace-function* nil))
  220.          (cons (cons 'quote (cons *trace-args* nil))
  221.           nil
  222.        )))
  223.       nil
  224.     ))
  225.   )
  226. )
  227. ; Eval-Form bauen, die einem Apply (näherungsweise) entspricht:
  228. (defun make-apply-form (funname args)
  229.   (declare (inline cons mapcar))
  230.   (cons funname
  231.     (mapcar #'(lambda (arg)
  232.                 ;(list 'quote arg)
  233.                 (cons 'quote (cons arg nil))
  234.               )
  235.             args
  236.   ) )
  237. )
  238. ; Output vor Aufruf, benutzt *trace-level* und *trace-form*
  239. (defun trace-pre-output ()
  240.   (%funcall '#,#'terpri *trace-output*)
  241.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  242.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  243.   (%funcall '#,#'prin1 *trace-form* *trace-output*)
  244. )
  245. ; Output nach Aufruf, benutzt *trace-level*, *trace-form* und *trace-values*
  246. (defun trace-post-output ()
  247.   (declare (inline car cdr consp atom))
  248.   (%funcall '#,#'terpri *trace-output*)
  249.   (%funcall '#,#'write *trace-level* :stream *trace-output* :base 10 :radix t)
  250.   (%funcall '#,#'write-string " Trace: " *trace-output*)
  251.   (%funcall '#,#'write (car *trace-form*) :stream *trace-output*)
  252.   (%funcall '#,#'write-string " ==> " *trace-output*)
  253.   (trace-print *trace-values* nil)
  254. )
  255. ; Output einer Liste von Werten:
  256. (defun trace-print (vals &optional (nl-flag t))
  257.   (when nl-flag (%funcall '#,#'terpri *trace-output*))
  258.   (when (consp vals)
  259.     (loop
  260.       (let ((val (car vals)))
  261.         (%funcall '#,#'prin1 val *trace-output*)
  262.       )
  263.       (setq vals (cdr vals))
  264.       (when (atom vals) (return))
  265.       (%funcall '#,#'write-string ", " *trace-output*)
  266. ) ) )
  267.  
  268. (defmacro untrace (&rest funs)
  269.   `(mapcan #'untrace1 ,(if (null funs) `(copy-list *traced-functions*) `',funs))
  270. )
  271.  
  272. (defun untrace1 (funname)
  273.   (unless (function-name-p funname)
  274.     (error #+DEUTSCH "~S: Funktionsname sollte ein Symbol sein, nicht ~S"
  275.            #+ENGLISH "~S: function name should be a symbol, not ~S"
  276.            #+FRANCAIS "~S : Le nom de la fonction doit être un symbole et non ~S"
  277.            'untrace funname
  278.   ) )
  279.   (let* ((symbol (get-funname-symbol funname))
  280.          (old-definition (get symbol 'sys::traced-definition)))
  281.     (prog1
  282.       (if old-definition
  283.         ; symbol war getraced
  284.         (progn
  285.           (if (and (fboundp symbol)
  286.                    (eq (symbol-function symbol) (get symbol 'sys::tracing-definition))
  287.               )
  288.             (progn
  289.               (replace-in-fenv old-definition funname (symbol-function symbol) old-definition)
  290.               (setf (symbol-function symbol) old-definition)
  291.             )
  292.             (warn #+DEUTSCH "~S: ~S war getraced und wurde umdefiniert!"
  293.                   #+ENGLISH "~S: ~S was traced and has been redefined!"
  294.                   #+FRANCAIS "~S : ~S était tracée et a été redéfinie!"
  295.                   'untrace funname
  296.           ) )
  297.           `(,funname)
  298.         )
  299.         ; funname war nicht getraced
  300.         '()
  301.       )
  302.       (untrace2 funname)
  303. ) ) )
  304.  
  305. (defun untrace2 (funname)
  306.   (let ((symbol (get-funname-symbol funname)))
  307.     (remprop symbol 'sys::traced-definition)
  308.     (remprop symbol 'sys::tracing-definition)
  309.   )
  310.   (setq *traced-functions* (delete funname *traced-functions* :test #'equal))
  311. )
  312.  
  313.